home *** CD-ROM | disk | FTP | other *** search
/ TeX 1995 July / TeX CD-ROM July 1995 (Disc 1)(Walnut Creek)(1995).ISO / macros / latex209 / contrib / slatex / funval.cl < prev    next >
Lisp/Scheme  |  1993-11-07  |  4KB  |  142 lines
  1. ;funval.cl
  2. ;makes CL treatment of functions and applications like Scheme's
  3. ;(c) Dorai Sitaram, December 1991, Rice University
  4.  
  5. ;advantage:
  6. ;no funcalls or #'s needed, ever
  7.  
  8. (progn
  9.   ;don't load this file twice
  10.   (when (fboundp 'letrec) (error "loading funval.cl twice!"))
  11.   ;print in lower case, since upper case ruins your eyes
  12.   (setq *print-case* :downcase))
  13.  
  14. (progn
  15.   ;make all identifiers with symbol-functions also have the function
  16.   ;as their symbol value
  17.   (do-all-symbols (x)
  18.     (cond ((boundp x) 'void)
  19.       ((macro-function x) 'void)
  20.       ((special-form-p x) 'void)
  21.       ((fboundp x) (setf (symbol-value x) (symbol-function x))))))
  22.  
  23. (defun insert-funcalls (e &optional bvs)
  24.   ;insert funcalls appropriately in the expression e
  25.   (if (not (consp e)) e
  26.     (let ((a (car e)))
  27.       (cond
  28.     ((and (consp a) (eq (car a) 'lambda))
  29.      (mapcar (function (lambda (e1) (insert-funcalls e1 bvs)))
  30.        e))
  31.     ((or (not (symbolp a)) (member a bvs :test (function eq)))
  32.      (cons 'funcall
  33.        (mapcar (function (lambda (e1) (insert-funcalls e1 bvs)))
  34.          e)))
  35.     ((eq a 'lambda)
  36.      (let* ((new-bvs (cadr e))
  37.         (ext-bvs (append new-bvs bvs)))
  38.        `(lambda ,new-bvs
  39.           ,@(mapcar (function 
  40.               (lambda (e1)
  41.                 (insert-funcalls e1 ext-bvs)))
  42.           (cddr e)))))
  43.     ((eq a 'quote) e)
  44.     ((eq a 'function)
  45.      (let ((d (insert-funcalls (cadr e) bvs)))
  46.        (if (and (consp d) (eq (car d) 'function))
  47.            d (list 'function d))))
  48.     ((eq a 'setq)
  49.      `(setq ,(cadr e) ,(insert-funcalls (caddr e) bvs)))
  50.     ((eq a 'let)
  51.      (let* ((new-bvs (mapcar (function car) (cadr e)))
  52.         (ext-bvs (append new-bvs bvs)))
  53.        `(let
  54.           ,(mapcar (function 
  55.              (lambda (x.i)
  56.                (let ((x (car x.i)) (i (cadr x.i)))
  57.                  `(,x ,(insert-funcalls i bvs)))))
  58.          (cadr e))
  59.           ,@(mapcar (function
  60.               (lambda (e1)
  61.                 (insert-funcalls e1 ext-bvs)))
  62.           (cddr e)))))
  63.     ((eq a 'let*)
  64.      (let ((x.i* (cadr e)) (x.ii* '()))
  65.        (loop (if (null x.i*)
  66.              (return
  67.                `(let* ,(reverse x.ii*)
  68.               ,@(mapcar (function
  69.                       (lambda (e1) 
  70.                     (insert-funcalls e1 bvs)))
  71.                   (cddr e))))
  72.              (let* ((x.i (car x.i*))
  73.                 (x (car x.i)) (i (cadr x.i)))
  74.                (setq x.i* (cdr x.i*))
  75.                (setq x.ii*
  76.              (cons (list x (insert-funcalls i bvs))
  77.                x.ii*))
  78.                (setq bvs (cons x bvs)))))))
  79.     ((eq a 'eval-when)
  80.      `(eval-when ,(cadr e)
  81.         ,@(mapcar (function 
  82.             (lambda (e1)
  83.               (insert-funcalls e1 bvs))) (cddr e))))
  84.     ((macro-function a)
  85.      (insert-funcalls (macroexpand e) bvs))
  86.     ((special-form-p a)
  87.      (mapcar (function
  88.            (lambda (e1) (insert-funcalls e1 bvs)))
  89.        e))
  90.     (t                ;i.e. is a (potential) symbol function
  91.       (cons a
  92.         (mapcar (function (lambda (e1) (insert-funcalls e1 bvs))) 
  93.           (cdr e))))))))
  94.  
  95. (progn
  96.   ;change eval to call insert-funcalls
  97.   (unless (fboundp 'common-lisp-eval)
  98.     (setf (symbol-function 'common-lisp-eval) (function eval))
  99.     (setq *evalhook*
  100.       (function
  101.         (lambda (form env)
  102.           (common-lisp-eval (insert-funcalls form)))))))
  103.  
  104. (defun insert-rest (xx)
  105.   ;change the ". z" format of scheme lambda to 
  106.   ;the "&rest z" format of cl lambda
  107.   (let ((yy '()))
  108.     (loop
  109.       (cond ((null xx) (return))
  110.         ((symbolp xx) 
  111.          (setq yy (cons xx (cons '&rest yy))) (return))
  112.         ((consp xx)
  113.          (setq yy (cons (car xx) yy))
  114.          (setq xx (cdr xx)))
  115.         (t (error "insert-rest"))))
  116.     (nreverse yy)))
  117.  
  118. (eval-when (compile load eval)
  119.   ;cl lambda will clash with new lambda, so shadow it
  120.   (shadow 'lambda))
  121.  
  122. (defmacro lambda (v . z)
  123.   ;install our new scheme lambda
  124.   `(function
  125.      (lisp:lambda
  126.        ,(insert-rest v)
  127.        ,@z)))
  128.  
  129. (defmacro define (x . z)
  130.   ;scheme-like define
  131.   (cond ((consp x) 
  132.      `(define ,(car x) (lambda ,(cdr x) ,@z)))
  133.     ((and (symbolp x) (null (cdr z)))
  134.      (let ((v (car z)))
  135.        `(progn
  136.           (setq ,x ,v)
  137.           (when (functionp ,x) (setf (symbol-function ',x) ,x))
  138.           (values))))
  139.     (t (error "define ~s" x))))
  140.  
  141. ; end funval.cl
  142.